home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / num_pred.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  3KB  |  215 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     Predicates on numbers
  9. */
  10. #include "include.h"
  11. #include "num_include.h"
  12.  
  13. number_zerop(x)
  14. object    x;
  15. {
  16.     switch (type_of(x)) {
  17.  
  18.     case t_fixnum:
  19.         if (fix(x) == 0)
  20.             return(1);
  21.         else
  22.             return(0);
  23.  
  24.     case t_bignum:
  25.     case t_ratio:
  26.         return(0);
  27.  
  28.     case t_shortfloat:
  29.         if (sf(x) == 0.0)
  30.             return(1);
  31.         else
  32.             return(0);
  33.  
  34.     case t_longfloat:
  35.         if (lf(x) == 0.0)
  36.             return(1);
  37.         else
  38.             return(0);
  39.  
  40.     case t_complex:
  41.         return(number_zerop(x->cmp.cmp_real) &&
  42.                number_zerop(x->cmp.cmp_imag));
  43.  
  44.     default:
  45.         FEwrong_type_argument(Snumber, x);
  46.     }
  47. }
  48.  
  49. number_plusp(x)
  50. object    x;
  51. {
  52.     switch (type_of(x)) {
  53.  
  54.     case t_fixnum:
  55.         if (fix(x) > 0)
  56.             return(1);
  57.         else
  58.             return(0);
  59.  
  60.     case t_bignum:
  61.         if (big_sign((struct bignum *)x) > 0)
  62.             return(1);
  63.         else
  64.             return(0);
  65.  
  66.     case t_ratio:
  67.         if (number_plusp(x->rat.rat_num))
  68.             return(1);
  69.         else
  70.             return(0);
  71.  
  72.     case t_shortfloat:
  73.         if (sf(x) > 0.0)
  74.             return(1);
  75.         else
  76.             return(0);
  77.  
  78.     case t_longfloat:
  79.         if (lf(x) > 0.0)
  80.             return(1);
  81.         else
  82.             return(0);
  83.  
  84.     default:
  85.         FEwrong_type_argument(TSor_rational_float);
  86.     }
  87. }
  88.  
  89. number_minusp(x)
  90. object    x;
  91. {
  92.     switch (type_of(x)) {
  93.  
  94.     case t_fixnum:
  95.         if (fix(x) < 0)
  96.             return(1);
  97.         else
  98.             return(0);
  99.  
  100.     case t_bignum:
  101.         if (big_sign((struct bignum *)x) < 0)
  102.             return(1);
  103.         else
  104.             return(0);
  105.  
  106.     case t_ratio:
  107.         if (number_minusp(x->rat.rat_num))
  108.             return(1);
  109.         else
  110.             return(0);
  111.  
  112.     case t_shortfloat:
  113.         if (sf(x) < 0.0)
  114.             return(1);
  115.         else
  116.             return(0);
  117.  
  118.     case t_longfloat:
  119.         if (lf(x) < 0.0)
  120.             return(1);
  121.         else
  122.             return(0);
  123.  
  124.     default:
  125.         FEwrong_type_argument(TSor_rational_float);
  126.     }
  127. }
  128.  
  129. number_oddp(x)
  130. object x;
  131. {
  132.     int    i;
  133.  
  134.     if (type_of(x) == t_fixnum)
  135.         i = fix(x);
  136.     else if (type_of(x) == t_bignum)
  137.         i = x->big.big_car;
  138.     else
  139.         FEwrong_type_argument(Sinteger, x);
  140.     return(i & 1);
  141. }
  142.  
  143. number_evenp(x)
  144. object x;
  145. {
  146.     int    i;
  147.  
  148.     if (type_of(x) == t_fixnum)
  149.         i = fix(x);
  150.     else if (type_of(x) == t_bignum)
  151.         i = x->big.big_car;
  152.     else
  153.         FEwrong_type_argument(Sinteger, x);
  154.     return(~i & 1);
  155. }
  156.  
  157. Lzerop()
  158. {
  159.     check_arg(1);
  160.     check_type_number(&vs_base[0]);
  161.     if (number_zerop(vs_base[0]))
  162.         vs_base[0] = Ct;
  163.     else
  164.         vs_base[0] = Cnil;
  165. }
  166.  
  167. Lplusp()
  168. {
  169.     check_arg(1);
  170.     check_type_or_rational_float(&vs_base[0]);
  171.     if (number_plusp(vs_base[0]))
  172.         vs_base[0] = Ct;
  173.     else
  174.         vs_base[0] = Cnil;
  175. }
  176.  
  177. Lminusp()
  178. {
  179.     check_arg(1);
  180.     check_type_or_rational_float(&vs_base[0]);
  181.     if (number_minusp(vs_base[0]))
  182.         vs_base[0] = Ct;
  183.     else
  184.         vs_base[0] = Cnil;
  185. }
  186.  
  187. Loddp()
  188. {
  189.     check_arg(1);
  190.     check_type_integer(&vs_base[0]);
  191.     if (number_oddp(vs_base[0]))
  192.         vs_base[0] = Ct;
  193.     else
  194.         vs_base[0] = Cnil;
  195. }
  196.  
  197. Levenp()
  198. {
  199.     check_arg(1);
  200.     check_type_integer(&vs_base[0]);
  201.     if (number_evenp(vs_base[0]))
  202.         vs_base[0] = Ct;
  203.     else
  204.         vs_base[0] = Cnil;
  205. }
  206.  
  207. init_num_pred()
  208. {
  209.     make_function("ZEROP", Lzerop);
  210.     make_function("PLUSP", Lplusp);
  211.     make_function("MINUSP", Lminusp);
  212.     make_function("ODDP", Loddp);
  213.     make_function("EVENP", Levenp);
  214. }
  215.